home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / threads.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  28KB  |  1,106 lines
  1. /* ******************************************************************** */
  2. /* threads.c         Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Lightweight processes                                        */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: threads.c,v 1.19 1992/06/01 13:48:33 pab Exp $
  9.  *
  10.  * $Log: threads.c,v $
  11.  * Revision 1.19  1992/06/01  13:48:33  pab
  12.  * clipper better fix
  13.  *
  14.  * Revision 1.18  1992/05/28  11:28:47  pab
  15.  * moved initialisation around for compiler
  16.  *
  17.  * Revision 1.17  1992/04/29  12:35:11  pab
  18.  * clipper hack
  19.  *
  20.  * Revision 1.16  1992/03/13  18:10:07  pab
  21.  * SysV fixes (protection around semaphores)
  22.  *
  23.  * Revision 1.15  1992/02/10  12:02:38  pab
  24.  * Debugger addition, plus sysV fix
  25.  *
  26.  * Revision 1.14  1992/02/03  00:38:43  pab
  27.  * pre sysV hack
  28.  *
  29.  * Revision 1.13  1992/01/29  20:10:43  pab
  30.  * fewer exports in Generic version
  31.  *
  32.  * Revision 1.12  1992/01/29  13:51:00  pab
  33.  * sysV fixes
  34.  *
  35.  * Revision 1.11  1992/01/21  22:23:52  pab
  36.  * fixed call to garbage_collect
  37.  *
  38.  * Revision 1.10  1992/01/15  21:23:52  pab
  39.  * Fixed alignment problems; made threads allocate int arrays
  40.  *
  41.  * Revision 1.9  1992/01/09  22:29:10  pab
  42.  * Fixed for low tag ints
  43.  *
  44.  * Revision 1.8  1992/01/07  22:15:37  pab
  45.  * ncc compatable, plus backtrace
  46.  *
  47.  * Revision 1.7  1992/01/07  16:18:35  pab
  48.  * tidy of continuation fns
  49.  *
  50.  * Revision 1.6  1992/01/05  22:48:30  pab
  51.  * Minor bug fixes, plus BSD version
  52.  *
  53.  * Revision 1.5  1991/12/22  15:14:43  pab
  54.  * Xmas revision
  55.  *
  56.  * Revision 1.4  1991/11/15  13:45:47  pab
  57.  * copyalloc rev 0.01
  58.  *
  59.  * Revision 1.3  1991/09/22  19:14:43  pab
  60.  * Fixed obvious bugs
  61.  *
  62.  * Revision 1.2  1991/09/11  12:07:49  pab
  63.  * 11/9/91 First Alpha release of modified system
  64.  *
  65.  * Revision 1.1  1991/08/12  16:50:09  pab
  66.  * Initial revision
  67.  *
  68.  * Revision 1.11  1991/06/17  19:01:05  pab
  69.  * Adjusted set_assoc
  70.  *
  71.  * Revision 1.10  1991/06/17  18:58:28  kjp
  72.  * just in case
  73.  *
  74.  * Revision 1.9  1991/04/16  17:59:57  kjp
  75.  * Tidy.
  76.  *
  77.  * Revision 1.8  1991/03/01  15:50:12  kjp
  78.  * Fixed any machine version.
  79.  *
  80.  * Revision 1.7  1991/02/28  14:14:48  kjp
  81.  * Lots of good stuff.
  82.  *
  83.  * Revision 1.6  1991/02/13  18:26:27  kjp
  84.  * Pass.
  85.  *
  86.  */
  87.  
  88. #define COBUG(x) /* fprintf(stderr,"COBUG:");x;fflush(stderr) */
  89.  
  90. /*
  91.  * Change Log:
  92.  *   Version 1, April 1990
  93.  */
  94.  
  95. #include "defs.h"
  96. #include "structs.h"
  97. #include "funcalls.h"
  98.  
  99. #include "global.h"
  100. #include "error.h"
  101.  
  102. #include "calls.h"
  103. #include "modboot.h"
  104. #include "symboot.h"
  105.  
  106. #include "allocate.h"
  107. #include "modules.h"
  108. #include "threads.h"
  109. #include "class.h"
  110. #include "vectors.h"
  111. #include "garbage.h"
  112.  
  113. extern void free(void*);
  114. extern LispObject Thread_Class;
  115.  
  116. int command_line_x_debug;
  117.  
  118. /* *************************************************************** */
  119. /* Simple functions for all machines                               */
  120. /* *************************************************************** */
  121.  
  122. EUFUN_1( Fn_threadp, obj)
  123. {
  124.   return((is_thread(obj)?lisptrue:nil));
  125. }
  126. EUFUN_CLOSE
  127.  
  128. EUFUN_0( Fn_current_thread)
  129. {
  130.   return(CURRENT_THREAD());
  131. }
  132. EUFUN_CLOSE
  133.  
  134. EUFUN_1( Fn_continuationp, obj)
  135. {
  136.   return (is_continue(obj) ? lisptrue : nil);
  137. }
  138. EUFUN_CLOSE
  139.  
  140. /* *************************************************************** */
  141. /* When machines can actually do stuff                             */
  142. /* *************************************************************** */
  143.  
  144. #ifndef MACHINE_ANY
  145.  
  146. #define SCHEDBUG(x) /* fprintf(scheduler_debug,"%d:",system_scheduler_number); \
  147.                     x ;fflush(scheduler_debug) ;*/ /*while(getchar()!='\n');*/
  148. #define SDS (scheduler_debug)
  149.  
  150. #define SET_STATE(th) \
  151.   (set_continue(stacktop,((th)->THREAD.state)))
  152.  
  153. #define PROCEED(cont,value) \
  154.   stacktop = load_thread(cont->CONTINUE.thread); \
  155.   call_continue(stacktop,cont,value);
  156.  
  157. #define RUN_THREAD(th) \
  158.   PROCEED(((th->THREAD.state)),th->THREAD.args);
  159.  
  160. #define RUN_DISPATCHER(arg) \
  161.   { \
  162.     LispObject th = SYSTEM_THREAD_SPECIFIC_VALUE(local_dispatcher_thread); \
  163.     PROCEED(((th->THREAD.state)),arg); \
  164.   }
  165.  
  166. #define STACK_FIDDLE (16)
  167.  
  168. #define HOG_THREAD(th)
  169. #define RELEASE_THREAD(th)
  170.  
  171. /* Queue for default scheduling methods... */
  172.  
  173. SYSTEM_GLOBAL(LispObject,list_ready_thread_queue);
  174. SYSTEM_GLOBAL(SystemSemaphore,list_ready_thread_queue_sem);
  175. static SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,local_dispatcher_thread);
  176. static SYSTEM_GLOBAL(LispObject,current_dispatcher_function);
  177. static SYSTEM_GLOBAL(LispObject,list_dispatcher_threads);
  178.  
  179. /* Stack switch user... */
  180.  
  181. static SYSTEM_THREAD_SPECIFIC_DECLARATION(jmp_buf,rig_escape);
  182. static SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,rig_thread);
  183.  
  184. /* REMEMBER: within this function, we're on the thread's stacks!!! */
  185.  
  186. void rig_thread_aux()
  187. {
  188.   LispObject *stacktop;
  189.   LispObject xx;
  190.  
  191.   LispObject thread = SYSTEM_THREAD_SPECIFIC_VALUE(rig_thread);
  192.   extern LispObject Fn_apply(LispObject*);
  193.  
  194.   if (!setjmp(thread->THREAD.state->CONTINUE.machine_state))
  195.     longjmp(SYSTEM_THREAD_SPECIFIC_VALUE(rig_escape),TRUE);
  196.  
  197.   stacktop = thread->THREAD.state->CONTINUE.gc_stack_pointer;
  198.   STACK_TMP(thread);
  199.   EUCALLSET_2(xx,
  200.           Fn_apply,thread->THREAD.fun,thread->THREAD.args);
  201.   UNSTACK_TMP(thread);
  202.   thread->THREAD.value=xx;
  203.   thread->THREAD.status = THREAD_RETURNED;
  204.  
  205.   STACK_TMP(thread);
  206.   SCHEDBUG((fprintf(SDS,"thread returned "),
  207.         EUCALL_2(Fn_print,thread,SchedOut)));
  208.   UNSTACK_TMP(thread);
  209.  
  210.   if (thread->THREAD.parent != nil) {
  211.     stacktop =load_thread(thread->THREAD.parent);
  212.     call_continue(stacktop,
  213.               ((thread->THREAD.parent->THREAD.state)),
  214.           thread->THREAD.value);
  215.   }
  216.  
  217.   RUN_DISPATCHER(thread);
  218. }
  219.   
  220. LispObject system_thread_rig(LispObject *stacktop, LispObject thread)
  221. {
  222.   int start; /* address to set sp register to */
  223.   /* Allocate the stacks */
  224.  
  225.   STACK_TMP(thread);
  226.   thread->THREAD.stack_base
  227.     = (int *) allocate_stack(stacktop,thread->THREAD.stack_size*sizeof(int));
  228.   UNSTACK_TMP(thread);
  229.   STACK_TMP(thread);
  230.   thread->THREAD.gc_stack_base
  231.     = (LispObject *) allocate_stack(stacktop,thread->THREAD.gc_stack_size*sizeof(int));
  232.   UNSTACK_TMP(thread);
  233.   STACK_TMP(thread);
  234.   thread->THREAD.state->CONTINUE.gc_stack_pointer
  235.     = thread->THREAD.gc_stack_base;
  236.  
  237.   if (setjmp(SYSTEM_THREAD_SPECIFIC_VALUE(rig_escape))) return(thread);
  238.   SYSTEM_THREAD_SPECIFIC_VALUE(rig_thread) = thread;
  239.   
  240.   if (thread->THREAD.stack_base==NULL)
  241.     CallError(stacktop,"Rig: Got strange thread\n",thread,NONCONTINUABLE);
  242.  
  243.   /* The ~7 is to align on a nice boundary --- no real point making it a #define */
  244.   start=(int) (thread->THREAD.stack_base
  245.                       + thread->THREAD.stack_size - STACK_FIDDLE)&(~7);
  246. #ifdef STACK_START_MISALIGNED
  247.   start+=4;
  248. #endif
  249.   stack_switch_and_go(start,
  250.               (int) rig_thread_aux);
  251.  
  252.   return(nil);
  253. }
  254.  
  255. /*
  256.  * Free re-usable resources of unrunnable threads... 
  257.  */
  258.  
  259. void shut_down_thread(LispObject *stacktop,LispObject th)
  260. {
  261.   void deallocate_stack(LispObject *, char *, int);
  262.  
  263.   th->THREAD.state->CONTINUE.gc_stack_pointer = NULL;
  264.   STACK_TMP(th);
  265.   deallocate_stack(stacktop,(char *) (th->THREAD.stack_base), 
  266.          th->THREAD.stack_size*sizeof(int));
  267.   deallocate_stack(stacktop,(char *) (th->THREAD.gc_stack_base),
  268.          th->THREAD.gc_stack_size*sizeof(int));
  269.   UNSTACK_TMP(th);
  270.   th->THREAD.stack_base = NULL;
  271.   th->THREAD.gc_stack_base = NULL;
  272.  
  273. /*
  274.   th->THREAD.stack_size = 0;
  275.   th->THREAD.gc_stack_size = 0;
  276. */
  277. }
  278.  
  279. /* Simple thread creation... */
  280.  
  281. #define MIN_THREAD_STACK_SIZE (4*1024)
  282. #define GC_STACK_RATIO        (4)
  283.  
  284. static SYSTEM_GLOBAL(LispObject,default_thread_stack_size);
  285.  
  286. EUFUN_0( Fn_default_thread_stack_size)
  287. {
  288.   return(SYSTEM_GLOBAL_VALUE(default_thread_stack_size));
  289. }
  290. EUFUN_CLOSE
  291.  
  292. EUFUN_1( Fn_default_thread_stack_size_setter, size)
  293. {
  294.   int csize;
  295.  
  296.   if (!is_fixnum(size))
  297.     CallError(stacktop,"(setter default-thread-stack-size): non-integer",
  298.           size,NONCONTINUABLE);
  299.  
  300.   csize = intval(size);
  301.  
  302.   if (csize < MIN_THREAD_STACK_SIZE)
  303.     CallError(stacktop,"(setter default-thread-stack-size): too small",
  304.           size,NONCONTINUABLE);
  305.  
  306.   SYSTEM_GLOBAL_VALUE(default_thread_stack_size) = size;
  307.  
  308.   return(size);
  309. }
  310. EUFUN_CLOSE
  311.   
  312. EUFUN_2(Fn_make_thread, fun, args)
  313. {
  314.   LispObject thread;
  315.  
  316.   if (!is_cons(args)) {
  317.  
  318.     thread 
  319.       = 
  320.     (LispObject) 
  321.       allocate_thread(stacktop,
  322.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  323.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  324.               0);
  325.   }
  326.   else {
  327.     LispObject size;
  328.     int csize;
  329.  
  330.     if (!is_fixnum((size = CAR(args))))
  331.       CallError(stacktop,"make-thread: invalid size",size,NONCONTINUABLE);
  332.  
  333.     csize = intval(size);
  334.  
  335.     if (csize <= 0)
  336.       CallError(stacktop,"make-thread: negative size",size,NONCONTINUABLE);
  337.  
  338.     if (csize < MIN_THREAD_STACK_SIZE)
  339.       CallError(stacktop,
  340.         "make-thread: size less than minimun",size,NONCONTINUABLE);
  341.  
  342.     thread = (LispObject) allocate_thread(stacktop,ALIGN_SIZE(csize),
  343.                       ALIGN_SIZE(csize/GC_STACK_RATIO),0);
  344.   }
  345.  
  346.   fun = ARG_0(stackbase);
  347.   thread->THREAD.fun = fun;
  348.   thread->THREAD.status = THREAD_LIMBO;
  349.  
  350.   return(thread);
  351. }
  352. EUFUN_CLOSE
  353.  
  354. EUFUN_1( Fn_thread_reset, th)
  355. {
  356.   if (!is_thread(th))
  357.     CallError(stacktop,"thread-reset: non thread",th,NONCONTINUABLE);
  358.  
  359.   if (th->THREAD.status != THREAD_RETURNED 
  360.        && th->THREAD.status != THREAD_ABORTED)
  361.     CallError(stacktop,"thread-reset: thread in use",th,NONCONTINUABLE);
  362.  
  363.   (void) system_thread_rig(stacktop,th);
  364.  
  365.   th = ARG_0(stackbase);
  366.   th->THREAD.value = nil;
  367.   th->THREAD.status = THREAD_LIMBO;
  368.  
  369.   return(th);
  370. }
  371. EUFUN_CLOSE
  372.  
  373. LispObject generic_thread_call;
  374.  
  375. EUFUN_2(Fn_thread_call, thread, args)
  376. {
  377.   LispObject me;
  378.  
  379.   if (!is_thread(thread))
  380.     CallError(stacktop,"thread-call: non-thread",thread,NONCONTINUABLE);
  381.  
  382.   if (thread->THREAD.status != THREAD_LIMBO)
  383.     CallError(stacktop,
  384.           "thread-call: thread not in limbo",thread,NONCONTINUABLE);
  385.  
  386.   /* Liberate the thread... */
  387.  
  388.   HOG_THREAD(thread);
  389.  
  390.   thread->THREAD.status = THREAD_RUNNING;
  391.   thread->THREAD.args = args;
  392.   me = CURRENT_THREAD();
  393.  
  394.   SCHEDBUG((fprintf(SDS,"Thread call from "), 
  395.         EUCALL_2(Fn_prin,me,SchedOut), 
  396.         fprintf(SDS," to "), 
  397.         EUCALL_2(Fn_print,th,SchedOut)));
  398.  
  399.   thread->THREAD.parent = me;
  400.  
  401.   RELEASE_THREAD(thread);
  402.  
  403.   if (SET_STATE(me)) {
  404.  
  405.     /* On caller... */
  406.  
  407.     SCHEDBUG((fprintf(SDS,"thread call returned to "),
  408.           EUCALL_2(Fn_print,me,SchedOut)));
  409.     
  410.     thread=ARG_0(stackbase);
  411.     thread->THREAD.parent = nil;
  412.     shut_down_thread(stacktop,thread);
  413.  
  414.     return(thread->THREAD.value);
  415.   }
  416.  
  417.   RUN_THREAD(thread);
  418.  
  419.   return(nil); /* Shouldn't get here */
  420. }
  421. EUFUN_CLOSE
  422.  
  423. /* Run on the dispatcher thread... */
  424.  
  425. EUFUN_1( Fn_next_ready_thread, c)
  426. {
  427.   LispObject thread;
  428.  
  429.   /* Peek... */
  430.  
  431.   if (SYSTEM_GLOBAL_VALUE(list_ready_thread_queue) == nil) return(nil);
  432.  
  433.   /* For real... */
  434.  
  435.   system_open_semaphore(stacktop,
  436.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  437.   if (SYSTEM_GLOBAL_VALUE(list_ready_thread_queue) == nil) {
  438.     system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  439.     return(nil);
  440.   }
  441.  
  442.   thread = CAR(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  443.   SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)
  444.     = CDR(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  445.  
  446.   system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  447.  
  448.   return(thread);
  449. }
  450. EUFUN_CLOSE
  451.  
  452. EUFUN_1( Fn_run_ready_thread, th)
  453. {
  454.  
  455. /*
  456.   #ifdef MACHINE_SYSTEMV
  457.   fprintf(stderr,"{R(%x):%x}",system_scheduler_number,(int) th);
  458.   fflush(stderr);
  459.   #endif
  460. */
  461.  
  462.   while (th->THREAD.status != THREAD_READY); /* Hedge */
  463.  
  464.   if (SET_STATE(CURRENT_THREAD())) {
  465.     th=ARG_0(stackbase);
  466.     return(th);
  467.   }
  468.   th=ARG_0(stackbase);
  469.   /* Have we done the stack business yet? */
  470.  
  471.   if (th->THREAD.stack_base == NULL) {
  472.     system_thread_rig(stacktop,th);
  473.     th = ARG_0(stackbase);
  474.   }
  475.  
  476.   th->THREAD.status = THREAD_RUNNING;
  477.  
  478.   RUN_THREAD(th);
  479.  
  480.   return(nil); /* Dummy */
  481. }
  482. EUFUN_CLOSE
  483.   
  484. #define SCHEDULER_RETRY_COUNT (1024) /* was 48*1024*/
  485.  
  486. EUFUN_0( Fn_dispatch)
  487. {
  488.   LispObject from = nil;
  489.   int tries = 0;
  490.  
  491.  restart:
  492.  
  493.   /*
  494.   if (SET_STATE(CURRENT_THREAD())) {
  495.     from = CURRENT_THREAD()->THREAD.state->CONTINUE.value;
  496.     goto restart;
  497.   }
  498.   */
  499.  
  500.   if (is_thread(from)) {
  501.  
  502.     switch (from->THREAD.status) {
  503.  
  504.      case THREAD_RETURNED:
  505.      case THREAD_ABORTED:
  506.  
  507.       (void) shut_down_thread(stacktop,from);
  508.       break;
  509.  
  510.      case THREAD_READY:
  511.  
  512.       {
  513.     LispObject cell = nil;
  514.     STACK_TMP(from); 
  515.     if (from->THREAD.cochain==nil)
  516.       {
  517.         LispObject xx;
  518.         xx=EUCALL_2(Fn_cons,nil,nil);
  519.         UNSTACK_TMP(from);
  520.         STACK_TMP(from);
  521.         from->THREAD.cochain=xx;
  522.         fprintf(stderr,"{}");
  523.       }
  524.     system_open_semaphore(stacktop,
  525.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  526.     UNSTACK_TMP(from);
  527.     cell=from->THREAD.cochain;
  528.         
  529.     CAR(cell)=from;
  530.     CDR(cell)=nil;
  531.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  532.             Fn_nconc,
  533.             SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),cell);
  534.     system_close_semaphore(
  535.             &SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  536.     
  537.     break;
  538.       }
  539.  
  540.      default:
  541.  
  542.       break;
  543.     }
  544.  
  545.   }
  546.  
  547.   SCHEDBUG(printf("Setting dispatch state...\n"); fflush(stdout));
  548.  
  549.   SCHEDBUG(printf("Dispatching...\n"); fflush(stdout));
  550.  
  551.   tries = 0;
  552.   while (TRUE) {
  553.  
  554.     while (tries < SCHEDULER_RETRY_COUNT) {
  555.       LispObject thread;
  556.  
  557.       EUCALLSET_1(thread, Fn_next_ready_thread, Thread);
  558.       if (is_thread(thread)) {
  559.     EUCALLSET_1(from, Fn_run_ready_thread, thread);
  560.     STACK_TMP(from);
  561.     GC_sync_test();
  562.     UNSTACK_TMP(from);
  563.     goto restart;
  564.       }
  565.  
  566.       GC_sync_test();
  567.  
  568.       ++tries;
  569.     }
  570.  
  571.     system_sleep_until_kicked();
  572.  
  573.     GC_sync_test();
  574.  
  575.     tries = 0;
  576.   }
  577.  
  578.   return(nil);
  579. }
  580. EUFUN_CLOSE
  581.   
  582. EUFUN_2(Fn_thread_start, thread, args)
  583. {
  584.   COBUG(fprintf(stderr,"In thread-start\n"));
  585.  
  586.   if (!is_thread(thread))
  587.     CallError(stacktop,
  588.           "thread-start: non-thread argument",thread,NONCONTINUABLE);
  589.  
  590.   if (thread->THREAD.status != THREAD_LIMBO)
  591.     CallError(stacktop,
  592.           "thread-start: thread not in limbo",thread,NONCONTINUABLE);
  593.  
  594.   HOG_THREAD(thread);
  595.  
  596.   /* Place the args inside and wind her up... */
  597.  
  598.   thread->THREAD.status = THREAD_READY;
  599.   thread->THREAD.args = args;
  600.  
  601.   RELEASE_THREAD(thread);
  602.  
  603.   /* Bung it on the ready queue... */
  604.  
  605.   STACK_TMP(thread);
  606.   system_open_semaphore(stacktop,&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  607.   UNSTACK_TMP(thread);
  608.   {
  609.     LispObject xx;
  610.     STACK_TMP(thread);
  611.     EUCALLSET_2(xx,Fn_cons,thread,nil);
  612.     
  613.     thread->THREAD.cochain=xx;
  614. /**    EUCALLSET_2(xx, Fn_cons,thread,nil);**/
  615.     CAR(thread->THREAD.cochain)=thread;
  616.     CDR(thread->THREAD.cochain)=nil;
  617.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  618.         Fn_nconc, SYSTEM_GLOBAL_VALUE(list_ready_thread_queue),
  619.         thread->THREAD.cochain);
  620.   }
  621.   system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  622.  
  623.   /* All is cool... */
  624.  
  625.   /* Poke layabouts... */
  626.  
  627.   system_kick_sleepers();
  628.  
  629.   return(ARG_0(stackbase));
  630. }
  631. EUFUN_CLOSE
  632.  
  633. EUFUN_0( Fn_thread_reschedule)
  634. {
  635.   LispObject thread = CURRENT_THREAD();
  636.  
  637.   HOG_THREAD(thread);
  638.   if (SET_STATE(thread)) return(nil);
  639.   RELEASE_THREAD(thread);
  640.  
  641. #ifdef nope /* Mon Mar  2 12:54:29 1992 */
  642. /**/  /* following lines commented out --- probably wrong */
  643. /**/  system_open_semaphore(stacktop,&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  644. /**/  SYSTEM_GLOBAL_VALUE(list_ready_thread_queue)
  645. /**/  = EUCALL_2(Fn_nconc,SYSTEM_GLOBAL_VALUE(list_ready_thread_queue), Fn_cons(thread,nil));
  646. /**/  system_close_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  647. /**/  /**/
  648. #endif /* nope Mon Mar  2 12:54:29 1992 */
  649.  
  650.   /* Call the dispatcher... */
  651.  
  652.   thread->THREAD.status = THREAD_READY;
  653.   RUN_DISPATCHER(thread);
  654.  
  655.   return(nil);
  656. }
  657. EUFUN_CLOSE
  658.  
  659. EUFUN_0( Fn_thread_suspend)
  660. {
  661.   LispObject thread = CURRENT_THREAD();
  662.  
  663.   /* Must be running */
  664.   STACK_TMP(thread);
  665.  
  666.   if (SET_STATE(thread))
  667.     {    
  668.       thread=ARG_0(stackbase);
  669.       return(thread->THREAD.args);
  670.     }
  671.  
  672.   thread->THREAD.status = THREAD_LIMBO;
  673.  
  674.   RUN_DISPATCHER(nil);
  675.  
  676.   return(nil);
  677. }
  678. EUFUN_CLOSE
  679.  
  680. EUFUN_0( Fn_abort_thread)
  681. {
  682.   LispObject thread = CURRENT_THREAD();
  683.  
  684.   HOG_THREAD(thread);
  685.   thread->THREAD.status = THREAD_ABORTED;
  686.   RELEASE_THREAD(thread);
  687.  
  688.   RUN_DISPATCHER(nil);
  689.  
  690.   return(nil);
  691. }
  692. EUFUN_CLOSE
  693.  
  694. EUFUN_1( Fn_thread_value, thread)
  695. {
  696.   if (!is_thread(thread))
  697.     CallError(stacktop,"thread-value: non-thread",thread,NONCONTINUABLE);
  698.  
  699.  switchstart:
  700.   thread=ARG_0(stackbase);
  701.   switch (thread->THREAD.status) {
  702.  
  703.    case THREAD_RETURNED:  return(thread->THREAD.value);
  704.  
  705.    case THREAD_LIMBO:
  706.    case THREAD_RUNNING:
  707.    case THREAD_READY: 
  708.     {
  709.       EUCALL_0(Fn_thread_reschedule);
  710.       goto switchstart;
  711.     }
  712.  
  713.    case THREAD_ABORTED: 
  714.      CallError(stacktop,
  715.            "thread_value: thread aborted",thread,NONCONTINUABLE);
  716.  
  717.    default: CallError(stacktop,
  718.               "thread-value: bad thread status",thread,NONCONTINUABLE);
  719.   }
  720.  
  721.   return(nil);
  722. }
  723. EUFUN_CLOSE
  724.  
  725. static LispObject sym_limbo;
  726. static LispObject sym_ready;
  727. static LispObject sym_running;
  728. static LispObject sym_returned;
  729. static LispObject sym_aborted;
  730.  
  731. EUFUN_1( Fn_thread_state, th)
  732. {
  733.   if (!is_thread(th))
  734.     CallError(stacktop,"thread-state: non-thread",th,NONCONTINUABLE);
  735.  
  736.   switch (th->THREAD.status) {
  737.  
  738.    case THREAD_LIMBO:    return(sym_limbo);
  739.    case THREAD_READY:    return(sym_ready);
  740.    case THREAD_RUNNING:  return(sym_running);
  741.    case THREAD_RETURNED: return(sym_returned);
  742.    case THREAD_ABORTED:  return(sym_aborted);
  743.  
  744.    default: CallError(stacktop,"thread-state: weird state",th,NONCONTINUABLE);
  745.  
  746.   }
  747.  
  748.   return(nil); /* Dummy */
  749. }
  750. EUFUN_CLOSE
  751.  
  752. EUFUN_0( Fn_thread_queue)
  753. {
  754.   return(SYSTEM_GLOBAL_VALUE(list_ready_thread_queue));
  755. }
  756. EUFUN_CLOSE
  757.  
  758. EUFUN_0( Fn_kick)
  759. {
  760.   system_kick_sleepers();
  761.   return(nil);
  762. }
  763. EUFUN_CLOSE
  764.  
  765. /* *************************************************************** */
  766. /*                        Allocation Methods                       */
  767. /* *************************************************************** */
  768.  
  769. static LispObject sym_stack_size;
  770.  
  771. EUFUN_2( Md_allocate_instance_Thread_Class, c, il)
  772. {
  773.   extern LispObject search_keylist(LispObject*,LispObject,LispObject);
  774.   LispObject new,size;
  775.   int i;
  776.  
  777.   if ((size = search_keylist(stacktop,il,sym_stack_size)) == unbound)
  778.     size = SYSTEM_GLOBAL_VALUE(default_thread_stack_size);
  779.   else {
  780.     
  781.     if (!is_fixnum(size))
  782.       CallError(stacktop,"allocate-instance(thread): non-integer stack size",
  783.         size,NONCONTINUABLE);
  784.  
  785.     if (intval(size) < MIN_THREAD_STACK_SIZE)
  786.       CallError(stacktop,"allocate-instance(thread): stack size too small",
  787.         size,NONCONTINUABLE);
  788.  
  789.   }
  790.  
  791.   new = 
  792.     (LispObject) 
  793.       allocate_thread(stacktop,
  794.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size)),
  795.               intval(SYSTEM_GLOBAL_VALUE(default_thread_stack_size))
  796.                  / GC_STACK_RATIO,
  797.               c->CLASS.local_count);
  798.  
  799.   lval_classof(new) = ARG_0(stackbase);
  800.  
  801.   return(new);
  802. }
  803. EUFUN_CLOSE
  804.  
  805. EUFUN_2( Md_initialize_instance_Thread, t, il)
  806. {
  807.   extern LispObject Md_initialize_instance_1(LispObject*);
  808.   extern LispObject search_keylist(LispObject*,LispObject,LispObject);
  809.   LispObject fun;
  810.  
  811.   if ((fun = search_keylist(stacktop,il,sym_function)) == unbound)
  812.     CallError(stacktop,"allocate-instance(thread): missing function value",
  813.           il,NONCONTINUABLE);
  814.  
  815.   t->THREAD.fun = fun;
  816.   t->THREAD.status = THREAD_LIMBO;
  817.  
  818.   return(EUCALL_2(Md_initialize_instance_1,t,il));
  819. }
  820. EUFUN_CLOSE
  821.  
  822. #endif
  823.  
  824. /* *************************************************************** */
  825. /*                          Output Methods                         */
  826. /* *************************************************************** */
  827.  
  828. extern LispObject Gf_generic_prin(LispObject*);
  829. extern LispObject generic_generic_prin;
  830. extern LispObject generic_generic_write;
  831.  
  832. EUFUN_2( Md_generic_prin_Thread, t, str)
  833. {
  834.   if (!is_stream(str))
  835.     CallError(stacktop,"generic-prin: not a stream",str,NONCONTINUABLE);
  836.  
  837.   fprintf(str->STREAM.handle,"#<");
  838.   EUCALL_2(Gf_generic_prin,classof(t)->CLASS.name,str);
  839.   t = ARG_0(stackbase);
  840.   str = ARG_1(stackbase);
  841.   fprintf(str->STREAM.handle,": %x %x ",(int) t,t->THREAD.status);
  842.   EUCALL_2(Gf_generic_prin,t->THREAD.value,str);
  843.   fprintf(ARG_1(stackbase)->STREAM.handle,">");
  844.  
  845.   return(ARG_0(stackbase));
  846. }
  847. EUFUN_CLOSE
  848.  
  849. /* *************************************************************** */
  850. /* Test'n'debug                                                    */
  851. /* *************************************************************** */
  852.  
  853. #ifndef MACHINE_ANY
  854.  
  855. LispObject test_reschedule_runner(LispObject* stacktop)
  856. {
  857.   while (TRUE) (void) EUCALL_0(Fn_thread_reschedule);
  858.  
  859.   return(nil);
  860. }
  861.  
  862. EUFUN_1( Fn_test_reschedule, n)
  863. {
  864.   int cn;
  865.  
  866.   cn = intval(n);
  867.  
  868.   while (cn--) {
  869.     LispObject th;
  870.  
  871.     th = allocate_module_function(stacktop, NULL, NULL,
  872.                   test_reschedule_runner,0);
  873.     EUCALLSET_2(th, Fn_make_thread, th, nil);
  874.  
  875.     printf("Test: %x\n",(int) th); fflush(stdout);
  876.  
  877.     EUCALL_2(Fn_thread_start,th,nil);
  878.   }
  879.  
  880.   EUCALL_0(Fn_thread_suspend);
  881.  
  882.   return(nil);
  883. }
  884. EUFUN_CLOSE
  885.  
  886. EUFUN_0( Fn_test_gc)
  887. {
  888.   
  889.   while (1) garbage_collect(stacktop);
  890.  
  891.   return(nil);
  892. }
  893. EUFUN_CLOSE
  894.  
  895. #endif
  896.  
  897. /* so we know who we are... Note that this is an expensive function to call*/
  898. EUFUN_0(Fn_feel_arch)
  899. {
  900. #ifdef MACHINE_ANY
  901.   return(get_symbol(stacktop,"generic"));
  902. #elif defined(MACHINE_BSD)
  903.   return(get_symbol(stacktop,"BSD"));
  904. #endif
  905. #ifdef MACHINE_SYSTEMV
  906.   return(get_symbol(stacktop,"System-V"));
  907. #endif
  908.   /* NOTREACHED*/
  909.   return(get_symbol(stacktop,"something-strange"));
  910. }
  911. EUFUN_CLOSE
  912. /* *************************************************************** */
  913. /* Initialisation of this section                                  */
  914. /* *************************************************************** */
  915.  
  916. #ifdef MACHINE_ANY
  917. #define THREADS_ENTRIES 7
  918. #else
  919. #define THREADS_ENTRIES 25
  920. #endif
  921.  
  922. #define SET_ASSOC(a,b) \
  923.   { LispObject tmp,tmp2; \
  924.     STACK_TMP(a); \
  925.     tmp2=b; \
  926.     UNSTACK_TMP(tmp); \
  927.     set_anon_associate(stacktop,tmp,tmp2); \
  928.   }
  929.  
  930. MODULE Module_threads;
  931. LispObject Module_threads_values[THREADS_ENTRIES];
  932.  
  933. void initialise_threads(LispObject *stacktop)
  934. {
  935.   open_module(stacktop,
  936.           &Module_threads,Module_threads_values,"threads",THREADS_ENTRIES);
  937.  
  938.   (void) make_module_function(stacktop,"threadp",Fn_threadp,1);
  939.   (void) make_module_function(stacktop,"current-thread",Fn_current_thread,0);
  940.   (void) make_module_function(stacktop,"continuationp",Fn_continuationp,1);
  941.  
  942.   (void) make_module_function(stacktop,"generic_generic_prin,Thread,Object",
  943.                   Md_generic_prin_Thread,2
  944.                   );
  945.   (void) make_module_function(stacktop,"generic_generic_write,Thread,Object",
  946.                   Md_generic_prin_Thread,2
  947.                   );
  948.  
  949.   (void) make_module_function(stacktop,"feel-machine-type",Fn_feel_arch,0);
  950.  
  951. #ifdef MACHINE_ANY
  952.   (void) make_module_entry(stacktop,"*threads-available*",nil);
  953. #else
  954.   (void) make_module_entry(stacktop,"*threads-available*",lisptrue);
  955. #endif
  956.  
  957. #ifndef MACHINE_ANY
  958.  
  959.   sym_stack_size = get_symbol(stacktop,"stack-size");
  960.   add_root(&sym_stack_size);
  961.   sym_limbo = get_symbol(stacktop,"limbo");
  962.   add_root(&sym_limbo);
  963.   sym_ready = get_symbol(stacktop,"ready");
  964.   add_root(&sym_ready);
  965.   sym_running = get_symbol(stacktop,"running");
  966.   add_root(&sym_running);
  967.   sym_returned = get_symbol(stacktop,"returned");
  968.   add_root(&sym_returned);
  969.   sym_aborted = get_symbol(stacktop,"aborted");
  970.   add_root(&sym_aborted);
  971.  
  972.   SYSTEM_INITIALISE_GLOBAL(LispObject,
  973.                default_thread_stack_size,
  974.                allocate_integer(stacktop,MY_THREAD_STACK_SIZE));
  975.   ADD_SYSTEM_GLOBAL_ROOT(default_thread_stack_size);
  976.  
  977.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_ready_thread_queue,nil);
  978.   ADD_SYSTEM_GLOBAL_ROOT(list_ready_thread_queue); 
  979.  
  980.   SYSTEM_INITIALISE_GLOBAL(LispObject,current_dispatcher_function,nil);
  981.   ADD_SYSTEM_GLOBAL_ROOT(current_dispatcher_function);
  982.  
  983.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_dispatcher_threads,nil);
  984.   ADD_SYSTEM_GLOBAL_ROOT(list_dispatcher_threads);
  985.  
  986.   SYSTEM_INITIALISE_GLOBAL(SystemSemaphore,list_ready_thread_queue_sem,NULL);
  987.   system_allocate_semaphore(&SYSTEM_GLOBAL_VALUE(list_ready_thread_queue_sem));
  988.  
  989.   (void) make_module_function(stacktop,"make-thread",Fn_make_thread,-2);
  990.   (void) make_module_function(stacktop,"thread-start",Fn_thread_start,-2);
  991.   (void) make_module_function(stacktop,"thread-reschedule",Fn_thread_reschedule,0);
  992.  
  993.   (void) make_module_function(stacktop,"thread-call",Fn_thread_call,-2);
  994.   (void) make_module_function(stacktop,"thread-value",Fn_thread_value,1);
  995.   (void) make_module_function(stacktop,"thread-suspend",Fn_thread_suspend,0);
  996.   (void) make_module_function(stacktop,"generic_allocate_instance,Thread_Class",
  997.                   Md_allocate_instance_Thread_Class,2);
  998.   (void) make_module_function(stacktop,"generic_initialize_instance,Thread_Class", /* XXX bad name */
  999.                   Md_initialize_instance_Thread,2);
  1000.  
  1001.   SYSTEM_GLOBAL_VALUE(current_dispatcher_function)
  1002.     = make_unexported_module_function(stacktop,"dispatcher",Fn_dispatch,0);
  1003.  
  1004.   (void) make_module_function(stacktop,"kick",Fn_kick,0);
  1005.  
  1006.   (void) make_module_function(stacktop,"not-thread-reset",Fn_thread_reset,1);
  1007.  
  1008.   (void) make_module_entry(stacktop,"*minimum-stack-size*",
  1009.                allocate_integer(stacktop,MIN_THREAD_STACK_SIZE));
  1010.  
  1011.   (void) make_module_function(stacktop,"thread-state",Fn_thread_state,1);
  1012.   (void) make_module_function(stacktop,"thread-queue",Fn_thread_queue,0);
  1013.  
  1014.   SET_ASSOC(make_module_function(stacktop,"default-thread-stack-size",
  1015.                  Fn_default_thread_stack_size,
  1016.                  0),
  1017.         make_module_function(stacktop,"(setter default-thread-stack-size)",
  1018.                  Fn_default_thread_stack_size_setter,
  1019.                  1));
  1020.        
  1021.   (void) make_module_function(stacktop,"test-reschedule",Fn_test_reschedule,1);
  1022.  
  1023.   (void) make_module_function(stacktop,"test-gc",Fn_test_gc,0);
  1024.  
  1025. #endif
  1026.  
  1027.   close_module();
  1028.  
  1029. }
  1030.  
  1031. #ifndef MACHINE_ANY
  1032.  
  1033. static SYSTEM_GLOBAL(int,start_register);
  1034.  
  1035. #define DISPATCHER_THREAD_STACK_SIZE (4*1048) /* Woz 4 */
  1036. #define DISPATCHER_THREAD_GC_STACK_SIZE (1024)
  1037.  
  1038. void runtime_begin_processes(LispObject* stacktop)
  1039. {
  1040.   extern void rig_gc_thread(LispObject *);
  1041.   extern int command_line_processors;
  1042.   int i;
  1043.  
  1044.   RUNNING_PROCESSORS() 
  1045.     = (command_line_processors == 0 ? 1 : command_line_processors);
  1046.  
  1047.   rig_gc_thread(stacktop);
  1048.  
  1049.   SYSTEM_INITIALISE_GLOBAL(int,start_register,0);
  1050.  
  1051.   for (i=0; i<RUNNING_PROCESSORS(); ++i) {
  1052.     int val;
  1053.     LispObject new_dt;
  1054.  
  1055.     /* Create and register dispatcher thread for each new process... */
  1056.  
  1057.     new_dt = allocate_thread(stacktop,
  1058.                  DISPATCHER_THREAD_STACK_SIZE,
  1059.                  DISPATCHER_THREAD_GC_STACK_SIZE,0);
  1060.  
  1061.     new_dt->THREAD.fun = SYSTEM_GLOBAL_VALUE(current_dispatcher_function);
  1062.  
  1063.     (void) system_thread_rig(stacktop,new_dt);
  1064.  
  1065.     EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_dispatcher_threads),
  1066.         Fn_cons,new_dt,SYSTEM_GLOBAL_VALUE(list_dispatcher_threads));
  1067.  
  1068.     val = (i == 0 ? 0 : fork());
  1069.  
  1070.     if (val == -1) {
  1071.       fprintf(stderr,"\nRats: fork wimped out\n\n"); fflush(stderr);
  1072.       system_lisp_exit(-1);
  1073.     }
  1074.     if (val == 0) { /* New! */
  1075.       SYSTEM_THREAD_SPECIFIC_VALUE(local_dispatcher_thread) = new_dt;
  1076.       add_root(&local_dispatcher_thread);
  1077. #ifndef NODEBUG
  1078. /*      startdb();*/
  1079. #endif
  1080.       if (i != 0) {
  1081.     runtime_reset_allocator(stacktop);
  1082.  
  1083.     break;
  1084.       }
  1085.  
  1086.     }
  1087.  
  1088.     ++SYSTEM_GLOBAL_VALUE(start_register);
  1089.  
  1090.   }
  1091.  
  1092.   system_register_process(i-1);
  1093.   SYSTEM_THREAD_SPECIFIC_VALUE(system_scheduler_number) = i-1;
  1094.  
  1095.   /* Wait for it... wait for it... */
  1096.  
  1097.   while (SYSTEM_GLOBAL_VALUE(start_register) != RUNNING_PROCESSORS());
  1098.   
  1099.   ON_collect();
  1100.  
  1101.   RUN_DISPATCHER(nil);
  1102. }
  1103.  
  1104. #endif
  1105.  
  1106.